home *** CD-ROM | disk | FTP | other *** search
/ Experimental BBS Explossion 3 / Experimental BBS Explossion III.iso / pascal / lzwp13.zip / MK_ARC.PAS < prev    next >
Pascal/Delphi Source File  |  1993-09-09  |  4KB  |  125 lines
  1. (*
  2. **   MK_ARC.PAS.C    Copyright (C) 1993 by MarshallSoft Computing, Inc.
  3. **
  4. **   This program is used to compress one or more files into a single
  5. **   archive file. For example, to compress all files ending with the
  6. **   extension '.PAS' into an archive named 'PAS.ARF', type:
  7. **
  8. **      MK_ARC *.PAS PAS.ARF
  9. *)
  10.  
  11.  
  12. program MK_ARC;
  13. uses dos, crt, memory, rw_io, hex_io, lzw_errs, LZW4P;
  14.  
  15. type
  16.   String12 = String[12];
  17.   AllocMemoryType = function(Size : Word) : Pointer;
  18.   FreeMemoryType  = function(P : Pointer; Size : Word) : Integer;
  19.  
  20. Var
  21.   InpFileName  : String12;
  22.   OutFileName  : String12;
  23.   MemoryP      : Pointer;
  24.   AllocMemoryP : Pointer;
  25.   FreeMemoryP  : Pointer;
  26.   ReaderP      : Pointer;
  27.   WriterP      : Pointer;
  28.   Size         : Integer;
  29.   Code         : Integer;
  30.   i, x         : Integer;
  31.   DirInfo      : SearchRec;
  32.   Ratio        : Real;
  33.   ReaderCnt    : Real;
  34.   WriterCnt    : Real;
  35.   Count        : Integer;
  36.   AccumCnt     : LongInt;
  37. begin
  38.   (* get file specs *)
  39.   if ParamCount <> 2 then
  40.     begin
  41.       writeln('Usage: MK_ARC <file_specs> <arc_file>');
  42.       halt;
  43.     end;
  44.   (* sign on *)
  45.   writeln('MK_ARC 1.0: Type any key to abort...');
  46.   writeln;
  47.   Count := 0;
  48.   (* open output *)
  49.   OutFileName := ParamStr(2);
  50.   (* force to upper case *)
  51.   for i := 1 to Length(OutFileName) do OutFileName[i] := UpCase(OutFileName[i]);
  52.   Code := WriterOpen(OutFileName);
  53.   if Code <> 0 then
  54.     begin
  55.       writeln('Cannot open ',OutFileName,' for output. IOResult = ',Code);
  56.       halt;
  57.     end;
  58.   (* get pointers *)
  59.   AllocMemoryP := @AllocMemory;
  60.   FreeMemoryP  := @FreeMemory;
  61.   ReaderP := @Reader;
  62.   WriterP := @Writer;
  63.   (* Initialize LZW *)
  64.   Code :=  InitLZW(AllocMemoryP,14);
  65.   (* consider each input file *)
  66.   FindFirst(ParamStr(1),0,DirInfo);
  67.   while DosError = 0 do
  68.   begin (* while *)
  69.     InpFileName := DirInfo.Name;
  70.     (*writeln('<',InpFileName,'>');*)
  71.     if KeyPressed then
  72.       begin
  73.         writeln;
  74.         writeln('Aborted by USER');
  75.         Halt;
  76.       end;
  77.     (* don't compress output file ! *)
  78.     if InpFileName = OutFileName then
  79.       begin
  80.          writeln('WARNING: Input file ',InpFileName,' same as output (skipping)');
  81.       end
  82.     else
  83.       begin
  84.         (* write file name to disk *)
  85.         for i := 1 to Length(InpFileName) do Code := Writer(ord(InpFileName[i]));
  86.         Code := Writer(0);
  87.         (* compress this file *)
  88.         Count := Count + 1;
  89.         (* open input file for compress *)
  90.         Code := ReaderOpen(InpFileName);
  91.         if Code <> 0 then
  92.           begin
  93.             writeln('Cannot open ',InpFileName,' for input. IOResult = ',Code);
  94.             halt;
  95.           end;
  96.         (* compress *)
  97.         write('COMPRESSING ',InpFileName:12,' ');
  98.         AccumCnt := WriterCount;
  99.         Code := Compress(ReaderP,WriterP);
  100.         if Code < 0 then
  101.           begin
  102.             SayError(Code);
  103.             Halt;
  104.           end;
  105.         (* report compression ratio *)
  106.         if ReaderCount > 0 then
  107.           begin
  108.             ReaderCnt := ReaderCount;
  109.             WriterCnt := WriterCount - AccumCnt;
  110.             Ratio := WriterCnt / ReaderCnt;
  111.             writeln('OK ',Ratio:6:2);
  112.           end
  113.         else writeln('???');
  114.         (* close input file *)
  115.         Code := ReaderClose;
  116.      end;
  117.     (* get next filename *)
  118.     FindNext(DirInfo);
  119.   end; (* while *)
  120.   (* close output *)
  121.   Code := WriterClose;
  122.   (* Terminate LZW *)
  123.   writeln(Count,' files archived.');
  124.   Code := TermLZW(FreeMemoryP);
  125. end.